home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1996 September / Software of the Month Club 1996 September.iso / mac / Software Research Institute-SRI / Business / Alpha ƒ / Tcl / SystemCode / fortran.tcl < prev    next >
Encoding:
Text File  |  1995-12-28  |  16.2 KB  |  548 lines  |  [TEXT/ALFA]
  1. #=============================================================================
  2. # Fortran mode definition and support procs
  3. #
  4. # Features:
  5. # 1.  Keyword colorization
  6. # 2.  Fortran-sensitive shift right/left preserve columns 1-6
  7. # 3.  Auto-indentation
  8. # 4.  Line-breaking with Ctl-Opt-J (a la emacs)
  9. # 5.  Subroutine indexing
  10. # 6.  Cmd-double-click subroutine and include-file lookup
  11. #
  12. #------------------------------------------------------------------------------
  13. # Author: Tom Pollard <pollard@chem.columbia.edu>
  14. #
  15. # To Do:  make comment char user modifiable?
  16. #         work around grep failure for Unix-format tag files
  17. #         F90 support?
  18. #
  19. # 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
  20. # 12/95 - cpp keyword colorization (George Nurser <g.nurser@soc.soton.ac.uk>)
  21. #         cmd-dbl-click supports cpp #include now
  22. # 11/95 - added FortBreakLine
  23. #         fixed case-sensitivity bug
  24. # 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
  25. #            improve performance (fortFindSub)
  26. #  9/95 - fixed getFortPrev bug with numbered lines
  27. #       - shiftLeft/Right revert to normal behavior on ill-formatted lines
  28. #  8/95 - auto-indentation is finally speedy and robust
  29. #  5/95 - added Cmd-Dbl-Click handler
  30. #       - added auto-indentation
  31. # 12/94 - fixed funcExpr, FortMarkFile search expressions
  32. #       - changed comment character from 'C' to 'c' (should be case-insensitive!)
  33. #       - added 'include' keyword
  34. #       - added FortShiftRight and FortShiftLeft procs
  35. #------------------------------------------------------------------------------
  36. proc dummyFort {} {}
  37.  
  38. newModeVar Fort sortedIsDefault    {0} 1
  39. newModeVar Fort wordWrap        {0}    1
  40. newModeVar Fort funcExpr    {^[^cC*!][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} 0
  41. newModeVar Fort autoMark        {0}    1
  42. newModeVar Fort electricTab        {1}    1
  43.  
  44. newModeVar Fort    prefixString    {c}    0
  45. newModeVar Fort    continueChar    {$}    0
  46.  
  47. newModeVar Fort indentComment    {0}    1
  48. newModeVar Fort markTag            {{}} 0
  49.  
  50. #=============================================================================
  51. # Fortran keywords
  52. #
  53. set FortKeywords { 
  54.     allocatable allocate assign backspace block call character close common 
  55.     complex contains continue cycle data deallocate dimension do double else 
  56.     elseif end enddo endfile endif entry equivalence exit external extrinsic 
  57.     forall format function goto if implicit include inquire integer intent 
  58.     interface intrinsic logical module namelist nullify open optional 
  59.     parameter pause pointer precision print private program public pure read 
  60.     real recursive return rewind save sequence stop subroutine target then 
  61.     use where while write
  62. }
  63. regModeKeywords -e {c} -c red -k blue Fort $FortKeywords 
  64. unset FortKeywords
  65.  
  66. #=============================================================================
  67. # selected C preprocessor keywords
  68. #
  69. set CPPKeywords  {
  70.     #if #endif #include #else #define #ifdef
  71. }
  72. regModeKeywords -a  -k green Fort $CPPKeywords
  73. unset CPPKeywords
  74.  
  75. #=============================================================================
  76. # Special Fortran keybindings
  77. #
  78. bind '\[' <c>  FortShiftLeft Fort
  79. bind '\[' <co> FortShiftLeftSpace Fort
  80. bind '\]' <c>  FortShiftRight Fort
  81. bind '\]' <co> FortShiftRightSpace Fort
  82.  
  83. bind '\t'       doATab Fort
  84. bind '\t' <o>     {doATab 1} Fort
  85. bind '\t' <z>     {doATab 1} Fort
  86.  
  87. bind 'j'  <zo> FortBreakLine Fort
  88.  
  89. #=============================================================================
  90. #
  91. proc FortMarkFile {} {
  92.     global FortmodeVars
  93.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  94.  
  95.   set pat0 {(subroutine|.*function|entry|program)}
  96.   set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  97.   set end [maxPos]
  98.   set pos 0
  99.   while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
  100.       regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
  101.       set start [lindex $mtch 0]
  102.       set end [nextLineStart $start]    
  103.       set pos $end
  104.       set inds([lineStart $start]) $name
  105.   }
  106.  
  107.   set pat2 "^(c+${tag})\[ \t\]*(\[^\n\r\]*\[^ \t\])\[^ \t\]*\$"
  108.   set pos 0
  109.   while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
  110.     regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
  111.     regsub -all {[\/\(\)]} $comment {} comment
  112.     set start [lindex $mtch 0]
  113.     set end [nextLineStart $start]
  114.     set pos $end
  115.     set inds([lineStart $start]) $comment
  116.   }
  117.  
  118.   if {[info exists inds]} {
  119.     foreach f [lsort -integer [array names inds]] {
  120.       set next [nextLineStart $f ]
  121.       setNamedMark $inds($f) $f $f $f
  122.     }
  123.   }
  124. }
  125.  
  126. #================================================================================
  127. # Block shift left and right for Fortran mode (preserves cols 1-6)
  128. #================================================================================
  129.  
  130. proc FortShiftLeft {} {
  131.     global shiftChar
  132.     doFortShiftLeft "\t"
  133.     
  134. }
  135. proc FortShiftLeftSpace {} {
  136.     global shiftChar
  137.     doFortShiftLeft " "
  138. }
  139.  
  140. proc doFortShiftLeft {shiftChar} {
  141.     set start [lineStart [getPos]]
  142.     set end [nextLineStart [expr [selEnd] - 1]]
  143.     if {$start >= $end} {set end [nextLineStart $start]}
  144.     
  145.     set text [split [getText $start [expr $end - 1]] "\r"]
  146.     
  147.     set textout ""
  148.     
  149.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
  150.     foreach line $text {
  151.         if {[regexp $pat $line mtch pref body]} {
  152.             if {[string index $body 0] == $shiftChar} {
  153.                 lappend textout $pref[string range $body 1 end]
  154.             } else {
  155.                 lappend textout $line
  156.             }
  157.  
  158.         } elseif {[string index $line 0] == $shiftChar} {
  159.             lappend textout [string range $line 1 end]
  160.  
  161.         } else {
  162.             lappend textout $line
  163.         }
  164.     }
  165.  
  166.     set text [join $textout "\r"]    
  167.     replaceText $start [expr $end - 1] $text
  168.     select $start [expr 1 + $start + [string length $text]]
  169. }
  170.  
  171. proc FortShiftRight {} {
  172.     global shiftChar
  173.     doFortShiftRight "\t"
  174.     
  175. }
  176. proc FortShiftRightSpace {} {
  177.     global shiftChar
  178.     doFortShiftRight " "
  179. }
  180.  
  181. proc doFortShiftRight {shiftChar} {
  182.     set start [lineStart [getPos]]
  183.     set end [nextLineStart [expr [selEnd] - 1]]
  184.     if {$start >= $end} {set end [nextLineStart $start]}
  185.     
  186.     set text [split [getText $start [expr $end - 1]] "\r"]
  187.     
  188.     set textout ""
  189.     
  190.     set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
  191.     foreach line $text {
  192.         if {[regexp $pat $line mtch pref body]} {
  193.             lappend textout $pref$shiftChar$body
  194.         } else {
  195.             lappend textout $shiftChar$line
  196.         }
  197.     }
  198.     
  199.     set text [join $textout "\r"]    
  200.     replaceText $start [expr $end - 1] $text
  201.     select $start [expr 1 + $start + [string length $text]]
  202. }
  203.  
  204. proc FortBreakLine {} {
  205.     global FortmodeVars
  206.     set pos [getPos]
  207.     set line [getText [lineStart $pos] [expr [nextLineStart $pos]-1]]
  208.     if {[regexp {^[cC*!]} $line char]} {
  209.         insertText "\n$char "
  210.     } else {
  211.         set char $FortmodeVars(continueChar)
  212.         insertText "\n     $char"
  213.     }
  214.     FortindentLine
  215. }
  216.  
  217. #=============================================================================
  218. # Cmd-double-clicking opens include files, jumps to subroutine definitions,
  219. # and follows tags.
  220. #
  221. proc FortDblClick {from to} {
  222.     global tagFile
  223.     set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
  224.     set incPat {^[^cC*!][ \t]*include[ \t]*['"]([^'"]+)['"]}
  225.  
  226.     # First check whether an 'include' was clicked
  227.     set line [getText [lineStart $from] [expr [nextLineStart $to] - 1]]
  228.     if {[regexp -nocase $incPat $line allofit fname]} {
  229.         set path [absolutePath $fname]
  230.         if {[catch {openFileQuietly $path}]} { 
  231.             message "include file \'$fname\' not found in source folder"
  232.         }
  233.         return
  234.     }
  235.     
  236.     select $from $to
  237.     set text [getSelect]
  238.     
  239.     # First check current file for subroutine definition,...
  240.     if {![catch {fortFindSub $text} mtch]} { 
  241.         regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
  242.         pushMark
  243.         display [lindex $mtch 0]
  244. #         eval select $mtch
  245.         message "press <Ctl .> to return to original cursor position"
  246.  
  247.     # ...then check tags file.
  248.     } else {
  249.         message "Searching tags file..."
  250.         set lines [grep "^$text'" $tagFile]
  251.         if {[regexp {'(.*)'} $lines dummy fname]} { 
  252.             if {[string match "*$fname*" [winNames -f]]} {
  253.                 bringToFront $fname
  254.             } else {
  255.                 edit $fname
  256.             }
  257.             set inds [fortFindSub $text]
  258. #             set inds [search -s -f 1 -r 1 "$pat1$text" 0]
  259.             display [lindex $inds 0]
  260. #             eval select $inds
  261.         }
  262.     }
  263. }
  264.  
  265. # Speedy search for a Fortran subroutine.  Performance is dramatically 
  266. # improved by scanning for the name alone first, rather than running 
  267. # complicated regexp search on the entire file.
  268. #
  269. proc fortFindSub {name} {
  270.     set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
  271.     set pos 0
  272.     while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
  273.         set beg [lineStart [lindex $mtch 0]]
  274.         set end [expr [nextLineStart [lindex $mtch 1]] -1]
  275.         set line [getText $beg $end]
  276.         if {[regexp  -nocase $pat1$name $line allofit subtyp name]} {
  277.             return $mtch 
  278.         } else {
  279.             set pos [lindex $mtch 1]
  280.         }
  281.     }
  282.     error "Subroutine \"$name\" not found"
  283. }
  284.  
  285. #=============================================================================
  286. # Fortan auto-indentation
  287. #
  288. # Logic:
  289. #    0.    Identify previous line
  290. #            a) ignore comments and continuation lines
  291. #            b) if current line is a CONTINUE that matches a DO, use the
  292. #                first corresponding DO as the previous line
  293. #
  294. #    1.    Find leading whitespace for previous line
  295. #
  296. #    2.    Increase whitespace if previous line starts a block, i.e.,
  297. #            a) DO loop
  298. #            b) IF ... THEN 
  299. #            c) ELSE
  300. #
  301. #    3.    Decrease whitespace if current line ends a block, i.e.,
  302. #            a) ELSE || ENDIF || END IF || ENDDO || END DO
  303. #            b) <linenum> CONTINUE matching a preceding DO
  304. #
  305. #        or if previous line ends a DO loop on an executable statement, i.e.,
  306. #            c) <linenum> (not CONTINUE) matching a preceding DO
  307. #
  308. ####################################################################################
  309. # Fortan auto-indentation
  310. #
  311. proc FortindentLine {} {    
  312.     set bol [lineStart [getPos]]
  313.     set eol [expr [nextLineStart $bol] - 1]
  314.     Fortindent $bol $eol
  315. }
  316.  
  317. proc FortindentRegion {} {    
  318.     Fortindent [getPos] [selEnd]
  319. }
  320.  
  321. ####################################################################################
  322. # Fortan auto-indentation of a specified region
  323. #
  324. proc Fortindent {pos0 pos1} {
  325.     global fortDooz fortPrevLine fortTop msg
  326.     global FortmodeVars
  327.  
  328.     set tag [quoteExpr2 $FortmodeVars(markTag)]
  329.     set doComment $FortmodeVars(indentComment)
  330.  
  331.     # Define regexps
  332.     set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  333.     set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
  334.     set mtPat {^[ \t]*$}
  335.     set tab "    "
  336.     
  337.     set contPat {^     ([^ \t\n\r])[^\r\n]*$}
  338.     set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
  339.     set comPat "^(\[cC*!\]+(${tag})?)(\[ \t\]*)(.*)\$"
  340.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  341.     set tailPat {[^\r\n]*$}
  342.     
  343.     set bobPat {^(if[^\n\r]*then|else|do)}
  344.     set eobPat {^(end[ \t]*if|end[ \t]*do|else)}
  345.     set enddoPat {^(end[ \t]*do|continue)}
  346.     
  347. #     set fortTop [fortSubTop $pos0]
  348.     set fortTop -1
  349.     
  350.     catch {unset fortDooz}
  351.     set fortPrevLine ""
  352.     
  353.     # Loop over region line by line
  354.     set from [lindex [posToRowCol $pos0] 0]
  355.     set to [lindex [posToRowCol $pos1] 0]
  356.     
  357.     while {$from <= $to} {        
  358.         set msg "Indenting line $from"
  359.         message $msg
  360.         set bol [lineStart [rowColToPos $from 0]]
  361.         set eol [expr [nextLineStart $bol] - 1]
  362.         set thisLine [getText $bol $eol]
  363.         goto $bol
  364.         
  365.         # Check whether we're entering a new routine
  366.         #
  367.         if {[regexp $subPat $thisLine allofit subType subName]} {
  368.             # alertnote "entering subr: \/$subName\/"
  369.             set fortTop $bol
  370.             catch {unset fortDooz}
  371.         } 
  372.         
  373.         # Is the current line a comment line...
  374.         #        
  375.         if {[regexp $comPat $thisLine allofit cc tag pre body]} {
  376.             if {$FortmodeVars(indentComment) > 0} {
  377.                 set body [string trimright $body]
  378.                 # alertnote "comment line: \/$pre\/$body\/"
  379.                 set lwhite "$cc     "
  380.                 
  381.                 replaceText $bol $eol $lwhite$body
  382.             }
  383.             
  384.         # ... or a line of code (possibly empty)?
  385.         #    
  386.         } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
  387.             set body [string trimright $body]
  388.             # alertnote "line: \/$pre\/$lnum\/$post\/$body\/"
  389.             
  390.             # is it a continuation line?
  391.             #
  392.             if {(![regexp {\t} $pre]) && ([string length $pre] == 5)} {
  393.                 set cont [string index $lnum$post$body 0]
  394.                 set body [string trimleft [string range $lnum$post$body 1 end]]
  395.             } else {
  396.                 set cont {}
  397.             }
  398.             # alertnote "cont: \/$cont\/"
  399.             
  400.             # get whitespace for preceding line
  401.             set enddo [getFortPrev $bol $lnum]
  402.             set lwhite [getFortLwhite $bol]
  403.             
  404.             # if this line ends a block, decrease the whitespace
  405.             if {[regexp $eobPat $body] || ($enddo && [regexp $enddoPat $body])} {
  406.                 set lwlen [expr [string length $lwhite] - 4]
  407.                 set lwhite [string range $lwhite 0 $lwlen]
  408.             } 
  409.             
  410.             if {[string length $lnum]} {
  411.                 if {[string index $lwhite 0] != $tab} {
  412.                     set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
  413.                 }
  414.                 set lnum " $lnum"
  415.             }
  416.             # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
  417.             # message "$msg : replacing text      "
  418.             
  419.             if {[string length $cont]} {
  420.                 replaceText $bol $eol "     $cont$lwhite$body"    
  421.             } else {
  422.                 replaceText $bol $eol $lnum$lwhite$body
  423.                 if {[string length $body] > 0} {
  424.                     set fortPrevLine $lnum$lwhite$body
  425.                 }
  426.             }
  427.         } else {
  428.             # message "$msg : Couldn't parse line         "
  429.         }
  430.         
  431.         # message "$msg : Done                "
  432.         incr from
  433.     }
  434. }
  435.  
  436. proc getFortLwhite {bol} {
  437.     global fortDooz fortPrevLine fortTop msg
  438.     # Define regexps
  439.     set tab "    "
  440.     set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
  441.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  442.     set bobPat {^(if[^\n\r]*then|else|do)}
  443.     set enddoPat {^(end[ \t]*do|continue)}
  444.     
  445.     if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
  446.         # alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"
  447.         
  448.         if {[string length $lnum0]} {
  449.             if {[string index $post0 0] == $tab} {
  450.                 set lwhite $post0
  451.             } else {
  452.                 regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
  453.             }
  454.         } else {
  455.             set lwhite $pre0
  456.         }
  457.         # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
  458.         # message "$msg : got lwhite (initial)"
  459.         
  460.         # if there's a line number and it's not a CONTINUE or ENDDO, 
  461.         # then check for a matching DO statement and adjust 
  462.         # indentation if found
  463.         #
  464.         if {[string length $lnum0] && ![regexp $enddoPat $body0]} {
  465.             if {[getFortPrev [lineStart [expr $bol - 1]] $lnum0]} {
  466.                 set lwlen [expr [string length $lwhite] - 4]
  467.                 set lwhite [string range $lwhite 0 $lwlen]
  468.  
  469.             }
  470.         }
  471.         
  472.         # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
  473.         # then increase the whitespace
  474.         #    
  475.         if {[regexp $bobPat $body0]} {
  476.             set lwhite "$lwhite   "
  477.             
  478.             if {[regexp "$doPat\(\[0-9\]+\)" $body0 mtch donum]} {
  479.                 set eol [expr [nextLineStart $bol] - 1]
  480.                 set fortDooz($donum) [getText $bol $eol]
  481.             }
  482.         }
  483.         # message "$msg : got lwhite (final)  "
  484.     }
  485.     return "$lwhite"
  486. }
  487.  
  488. proc getFortPrev {bol lnum} {        
  489.     global fortDooz fortPrevLine fortTop msg
  490.     # Define regexps
  491.     set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
  492.     set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
  493.     set contPat {^     ([^ \t\n\r])[^\r\n]*$}
  494.  
  495.     # if there's a line number, check for a matching DO statement ...
  496.     if {[string length $lnum]} {
  497.         if {[lsearch [array names fortDooz] $lnum] >= 0} {
  498.             set fortPrevLine $fortDooz($lnum)
  499.             return 1
  500.         } else {
  501.             if {$fortTop < 0} {
  502.                 set fortTop [fortSubTop $bol]
  503.             }
  504.             if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
  505.                 set fortPrevLine [eval getText $dolst]
  506.                 set fortDooz($lnum) $fortPrevLine
  507.                 # alertnote "doLine0: \/$fortPrevLine\/"
  508.                 return 1
  509.             }
  510.         }
  511.     }
  512.         
  513.     # ... otherwise find the first preceding non-comment, non-continuation line
  514.     if {[string length $fortPrevLine] == 0} {
  515.         if {[catch {
  516.             set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
  517.             set fortPrevLine [eval getText $lst]
  518.             while {[regexp $contPat $fortPrevLine]} {
  519.                 set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
  520.                 set fortPrevLine [eval getText $lst]
  521.             }
  522.         }]} {
  523.             # if search fails, we're at the top of a file, so reset indentation
  524.             set fortPrevLine "      continue"
  525.         }
  526.     }
  527.     
  528.     # alertnote "prevLine: \/$fortPrevLine\/"
  529.     # message "$msg : got prevLine"
  530.     return 0
  531. }
  532.  
  533. # Find the beginning of the current subroutine
  534. #
  535. proc fortSubTop {{pos 0}} {
  536.     if {$pos == 0} {
  537.         set pos [lineStart [getPos]]
  538.     }
  539.     set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
  540.     
  541.     if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
  542.         # set subLine [eval getText $sublst]
  543.         # alertnote "subLine: \/$subLine\/"
  544.         return [lindex $sublst 0]
  545.     } else {
  546.         return 0
  547.     } 
  548. }